;;; -*- Mode:LISP; Package:(PCL Lisp 1000); Base:10.; Syntax:Common-lisp -*-
;;;
;;; *************************************************************************
;;; Copyright (c) 1985 Xerox Corporation.  All rights reserved.
;;;
;;; Use and copying of this software and preparation of derivative works
;;; based upon this software are permitted.  Any distribution of this
;;; software or derivative works must comply with all applicable United
;;; States export control laws.
;;; 
;;; This software is made available AS IS, and Xerox Corporation makes no
;;; warranty about the software, its performance or its conformity to any
;;; specification.
;;; 
;;; Any person obtaining a copy of this software is requested to send their
;;; name and post office or electronic mail address to:
;;;   CommonLoops Coordinator
;;;   Xerox Artifical Intelligence Systems
;;;   2400 Hanover St.
;;;   Palo Alto, CA 94303
;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
;;;
;;; Suggestions, comments and requests for improvements are also welcome.
;;; *************************************************************************
;;;
;;; This is the 1100 (Xerox version) of the file portable-low.
;;;

(in-package 'pcl)

(defmacro load-time-eval (form)
  `(LOADTIMECONSTANT ,form))

  ;;   
;;;;;; Memory block primitives.
  ;;

(defmacro make-memory-block (size &optional area)
  `(\\allocblock ,size T))

(defmacro memory-block-ref (block offset)
  `(\\GETBASEPTR ,block (* 2 ,offset)))

(defsetf memory-block-ref setf-memory-block-ref) 


(defmacro memory-block-size (block)
  ;; this returns the amount of memory allocated for the block --
  ;; it may be larger than size passed at creation
  `(\\#BLOCKDATACELLS , block))

(defmacro CLEAR-memory-block (block start)
  (once-only (block)
    `(do ((end (memory-block-size ,block))
	  (index ,start (+ index 1)))
	 ((= index end))
       (setf (memory-block-ref ,block index) nil))))

(defmacro %allocate-static-slot-storage--class (no-of-slots)
  `(\\ALLOCBLOCK ,no-of-slots T))

(defmacro %static-slot-storage-get-slot--class (static-slot-storage slot-index)
  `(\\GETBASEPTR ,static-slot-storage (* 2 ,slot-index)))

(defsetf %static-slot-storage-get-slot--class setf-memory-block-ref)  
						            
(defmacro setf-memory-block-ref (static-slot-storage slot-index new-value)
  `(\\RPLPTR , static-slot-storage (* 2 ,slot-index) , new-value))	

;(defmacro %convert-slotd-position-to-slot-index (slotd-position)
; `(* 2 ,slotd-position))


  ;;   
;;;;;; FUNCTION-ARGLIST
  ;;

(movd 'arglist 'function-arglist)

  ;;   
;;;;;; 
  ;;   

(defconstant maxntypx 256)

(defvar *lisp-class-table* (\\allocblock maxntypx t))

(defmacro lisp-class-table-entry (ntypx)
  `(\\getbaseptr *lisp-class-table* (llsh ,ntypx 1)))

(eval-when (load eval compile)
  (iterate ((type-no from 0 below maxntypx))
    (setf (lisp-class-table-entry type-no) 'no-class-indicator))
  
  (setf (lisp-class-table-entry (\\typenumberfromname (quote iwmc-class))) nil))

(defun no-class-indicator (obj)
  (setf (lisp-class-table-entry (ntypx obj))
	(OR (CLASS-NAMED (TYPE-OF obj))		;I don't see how this can be right, what if
	    (class-named t))))			;Someone defines a type with this number
						;later on?

(defun class-of (x)
  (let ((class-indicator (lisp-class-table-entry (ntypx x))))
    (cond ((null class-indicator)
	    (class-wrapper-class (iwmc-class-class-wrapper x)))
	  ((symbolp class-indicator)
	   (funcall class-indicator x))
	  (t class-indicator))))


  ;;   
;;;;;; Generating CACHE numbers
  ;;

(defmacro symbol-cache-no (symbol mask)
  `(logand (llsh (logand 8191 (\\loloc ,symbol)) 2) ,mask))	;8191 is #O17777

(defmacro object-cache-no (object)
  `(logand (\\loloc ,object) ,mask))


  ;;   
;;;;;; printing-random-thing-internal
  ;;
(defun printing-random-thing-internal (thing stream)
  (princ (\\hiloc thing) stream)
  (princ "," stream)
  (princ (\\loloc thing) stream))

(defmacro pre-make-templated-function-constructor (name
						   &rest template-parameters)
  ())

(defun make-templated-function-constructor-constructor (template-params instance-params body)
  `(deferredconstant
     (compile ()
       '(lambda ,template-params
	  (declare (specvars . ,template-params))
	  (let* ((instance-params ,instance-params)
		 (prototype (progn ,@body))
		 (constants (iterate ((param in instance-params))
			      (collect (list 'quote (list param))))))
	    (and (listp prototype)
		 (eq (car prototype) 'function)
		 (setq prototype (cadr prototype)))
	    (setq prototype (compile () (change-vars-to-constants prototype
								  instance-params
								  constants)))
	    (compile nil
	      `(lambda ,instance-params
		 (let ((new-fn (copy-compiled-code ',prototype)))
		   ,@(iterate ((param in instance-params)
			       (constant in constants))
		       (collect
			 `(change-constant-in-compiled-code new-fn ,constant ,param)))
		   new-fn))))))))

(defun make-lexical-environment (macrolet/flet/labels-form e